home *** CD-ROM | disk | FTP | other *** search
/ MacHack 1996 / MacHack 1996.toast / Presentations / Presentations ’93 / Voice Toolkit / Voice Sequence < prev    next >
Lisp/Scheme  |  1993-03-02  |  3KB  |  95 lines
  1.  
  2. (in-package "VOICE-TOOLKIT")
  3.  
  4. (export '(voice-sequence initialize-instance cell-contents table-sequence 
  5.           set-table-sequence))
  6.  
  7. (defclass voice-sequence (sequence-dialog-item)
  8.   ((finder :accessor finder :initform (make-hash-table :test #'equal))
  9.    (careful :accessor careful :initarg :careful :initform t)
  10.    (exclusive :accessor exclusive :initform t)))
  11.  
  12. (defmethod identify ((vs voice-sequence))
  13.   (mapcar #'identify (actual-table-sequence vs)))
  14.  
  15. (defmethod initialize-instance ((vs voice-sequence) &rest args)
  16.   (apply #'call-next-method (cons vs (make-voice-shell args)))
  17.   (setf (exclusive vs) (exclusive-p args)))
  18.  
  19. (defun exclusive-p (arglist)
  20.   (cond ((null arglist))
  21.         ((equal (first arglist) :selection-type)
  22.          (equal (second arglist) :single))
  23.         (t (exclusive-p (rest arglist)))))
  24.  
  25. (defmethod make-slots ((vs voice-sequence) somelist)
  26.   (if (onscreen-p vs)
  27.     (remove-voice-items (set-diff (actual-table-sequence vs)
  28.                                   (existing-slots (actual-table-sequence vs)
  29.                                                   somelist))))
  30.   (items-to-slots somelist
  31.                   (existing-slots (actual-table-sequence vs)
  32.                                   somelist)
  33.                   (mapcar #'(lambda (item)
  34.                               (make-slot vs item))
  35.                           (set-diff somelist (table-sequence vs)))))
  36.  
  37. (defun items-to-slots (items oldslots newslots)
  38.   (if items
  39.     (cons (first (or (member (first items) oldslots :test #'in-slot)
  40.                      (member (first items) newslots :test #'in-slot)))
  41.           (items-to-slots (rest items) oldslots newslots))))
  42.  
  43.  
  44. (defun make-slot (vs item)
  45.   (make-instance 'voice-slot
  46.     :text (format nil "~a" item)
  47.     :contents item
  48.     :owner vs
  49.     :careful (careful vs)))
  50.  
  51. (defmethod mark-item ((vs voice-sequence) slot)
  52.   (cell-select vs 0 slot)
  53.   (scroll-to-cell vs 0 slot))
  54.  
  55. (defmethod unmark-item ((vs voice-sequence) slot)
  56.   (cell-deselect vs 0 (find-slot vs slot)))
  57.  
  58. (defmethod cell-contents ((vs voice-sequence) h &optional v)
  59.   (contents (call-next-method vs h v)))
  60.  
  61. (defmethod find-slot ((vs voice-sequence) slot)
  62.   (gethash slot (finder vs)))
  63.  
  64. (defmethod file-sequence-items ((vs voice-sequence) newslots)
  65.   (clear-finder vs)
  66.   (file-item-order (finder vs) newslots)
  67.   newslots)
  68.  
  69. (defun file-item-order (table items &optional (count 0))
  70.   (if items
  71.     (progn
  72.       (setf (gethash (first items) table) count)
  73.       (file-item-order table (rest items) (+ count 1)))))
  74.  
  75. (defmethod clear-finder ((vs voice-sequence))
  76.   (clrhash (finder vs)))
  77.  
  78. (defmethod set-table-sequence ((vs voice-sequence) somelist)
  79.   (call-next-method vs (file-sequence-items vs (make-slots vs somelist)))
  80.   (if (onscreen-p vs) (file-voice-items (actual-table-sequence vs))))
  81.  
  82. (defmethod table-sequence ((vs voice-sequence))
  83.   (slot-values (call-next-method vs)))
  84.  
  85. (defmethod actual-table-sequence ((vs voice-sequence))
  86.   (let ((hold nil))
  87.     (maphash #'(lambda (k v)
  88.                  v
  89.                  (setf hold (cons k hold)))
  90.              (finder vs))
  91.     hold))
  92.  
  93.  
  94.  
  95.